perm filename MODITO.LSP[SYS,HE] blob
sn#564269 filedate 1982-09-03 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00062 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 Load up files for compilation.
C00006 00003 Declarations for the compiler.
C00007 00004 b[] causes PARSEing of BARM
C00008 00005 create-cone-descriptor[obj]
C00009 00006 create-scene-obj[]
C00010 00007 create-scene-obj-for-ls[x1,y1,z1,x2,y2,z2]
C00013 00008 create-simple-cone[]
C00015 00009 create-sub-cone[c]
C00016 00010 create-subpart[obj]
C00018 00011 delete-sub-cone[c]
C00021 00012 edit-affixment[af]
C00024 00013 edit-cone[c]
C00028 00014 edit-cross-section[cs]
C00030 00015 edit-cross-section-circle[cs]
C00032 00016 edit-cross-section-rectangle[cs]
C00035 00017 edit-cross-section-regular-polygon[cs]
C00038 00018 edit-cross-section-square[cs]
C00040 00019 edit-cross-section-type[cs]
C00042 00020 edit-display[sc]
C00043 00021 edit-fixnum[n]
C00044 00022 edit-flonum[x]
C00045 00023 edit-object[obj]
C00048 00024 edit-orientation[ori-instance]
C00050 00025 edit-position[pos-instance]
C00052 00026 edit-scene[sc]
C00055 00027 edit-scene-obj[so]
C00058 00028 edit-simple-cone[sc]
C00061 00029 edit-spine[sp]
C00063 00030 edit-spine-circular-segment[sp]
C00066 00031 edit-spine-non-perp[sp]
C00069 00032 edit-spine-straight[sp]
C00071 00033 edit-spine-type[sp]
C00073 00034 edit-sub-cone[sbc]
C00076 00035 edit-sup-to[obj]
C00079 00036 edit-subparts[obj]
C00082 00037 edit-sweeping-rule[sr]
C00084 00038 edit-sweeping-rule-bilinear[sr]
C00087 00039 edit-sweeping-rule-constant[sr]
C00089 00040 edit-sweeping-rule-linear[sr]
C00091 00041 edit-sweeping-rule-type[sr]
C00093 00042 mark-written[name]
C00094 00043 marked-written[name]
C00095 00044 moditor[]
C00096 00045 moditor-cmd-exe[]
C00097 00046 (DEFUN MODITOR-CMD-UVAR ()
C00099 00047 moditor-cmd-w[]
C00101 00048 moditor-draw[]
C00102 00049 set-moditor-screen[]
C00103 00050 universal-cmd[cmd]
C00105 00051 write-affixment[af]
C00107 00052 write-affixments[obj]
C00108 00053 write-cone[cd,n]
C00109 00054 write-cs[cs,n]
C00111 00055 write-ob[ob]
C00113 00056 write-sc[sc,n]
C00117 00057 write-scene[scene]
C00118 00058 write-so[so]
C00120 00059 write-sp[sp,n]
C00122 00060 write-sr[sr,n]
C00124 00061 write-sub-cone[sub-cone]
C00126 00062 write-uvars-ucons[]
C00127 ENDMK
C⊗;
;Load up files for compilation.
(EVAL-WHEN (COMPILE)
(OR (BOUNDP '|.loaded.|) (FASLOAD LOADER FAS DSK (SYS ROD)))
(LOADUP (RECORD FAS DSK (SYS ROD))
(USEDEC LSP DSK (SYS ROD))
(DECLAR LSP DSK (SYS ROD))
(GRAPHS LSP DSK (SYS ROD))
(MODITO REC DSK (SYS BIS) L)))
;Declarations for the compiler.
(DECLARE (SETQ IBASE 10. BASE 10.))
(DECLARE (SPECIAL $SIMULATOR-CAMERA-SET))
(DECLARE (SPECIAL $EXE-FILES))
;b[] causes PARSEing of BARM
(DEFUN B ()
(APPLY 'PARSE '(BARM MOD DSK (SYS BIS)))
) ;end-defun
;create-cone-descriptor[obj]
;creates a CONE-DESCRIPTOR for the OBJECT OBJ
;if the user really wants us to.
(DEFUN CREATE-CONE-DESCRIPTOR (OBJ)
(TERPRI)
(WRITE '|Do you really want to create a CONE-DESCRIPTOR for | OBJ '| ? |)
(IF (READ-YES)
THEN
(TERPRI)
(WRITE '|What should I name this CONE? (`ANY' means I choose.) |)
∂OBJECT:CONE-DESCRIPTOR[OBJ]
← (CREATE CONE
SELF (LET NAME ← (BIS-READ)
DO
(IF (EQ 'ANY NAME)
THEN (CATEN OBJ '-CONE)
ELSE NAME))))
) ;end-defun
;create-scene-obj[]
;creates and returns a null SCENE-OBJ with a name the user chooses.
(DEFUN CREATE-SCENE-OBJ ()
(TERPRI)
(WRITE '|Name of the new OBJECT? |)
(CREATE SCENE-OBJ
OBJECT {SELF (BIS-READ)})
) ;end-defun
;create-scene-obj-for-ls[x1,y1,z1,x2,y2,z2]
;creates a SCENE-OBJ which represents the 3-D line segment
;given in the arguments.
;The SCENE-OBJ is added into $CURRENT-SCENE.
(DEFUN CREATE-SCENE-OBJ-FOR-LS (X1 Y1 Z1 X2 Y2 Z2)
;Create the SPINE, CROSS-SECTION, and SWEEPING-RULE.
(LET XDIF ← (-$ X2 X1)
YDIF ← (-$ Y2 Y1)
ZDIF ← (-$ Z2 Z1)
THEN
SP ← (CREATE SPINE
TYPE 'NON-PERP
LENGTH (SQRT (+$ (*$ XDIF XDIF) (*$ YDIF YDIF) (*$ ZDIF ZDIF)))
Y-DISP YDIF
Z-DISP ZDIF)
CS ← (CREATE CROSS-SECTION TYPE 'CIRCLE RADIUS 0.1)
SR ← (CREATE SWEEPING-RULE TYPE 'CONSTANT)
THEN
;Create the required SIMPLE-CONE.
SC ← (CREATE SIMPLE-CONE
SPINE SP
CROSS-SECTION CS
SWEEPING-RULE SR
DISPLAY 'SPINES)
THEN
;Create the required CONE-DESCRIPTOR.
CD ← (CREATE CONE MAIN-CONE SC)
NAME ← (GENSYM 'LS-)
THEN
;Create the required OBJECT.
OB ← (CREATE OBJECT
SELF NAME
CONE-DESCRIPTOR CD)
THEN
;Create the required SCENE-OBJ.
SO ← (CREATE SCENE-OBJ
OBJECT OB
POSITION (CREATE POSITION
SYMBOLIC (LIST X1 Y1 Z1)))
THEN
OLD-SCENE-LIST ← ∂SCENE:SCENE-LIST[$CURRENT-SCENE]
DO
;Add the SCENE-OBJ into $CURRENT-SCENE so it displays.
∂SCENE:SCENE-LIST[$CURRENT-SCENE] ← (ADD-AT-END OLD-SCENE-LIST SO)
NIL)
) ;end-defun
;create-simple-cone[]
;creates and returns a SIMPLE-CONE.
(DEFUN CREATE-SIMPLE-CONE ()
(TERPRI)
(WRITE '|Do you really want to create a SIMPLE-CONE ? |)
(IF (READ-YES)
THEN
(WRITE '|What should I name this SIMPLE-CONE? (`ANY' means I choose.) |)
(LET SP ← (CREATE SPINE TYPE 'STRAIGHT LENGTH 10.0)
CS ← (CREATE CROSS-SECTION
TYPE 'REGULAR-POLYGON
RADIUS 1.0
SIDES 6)
SR ← (CREATE SWEEPING-RULE
TYPE 'CONSTANT)
DO
(CREATE SIMPLE-CONE
SELF (LET NAME ← (BIS-READ)
DO
(IF (EQ 'ANY NAME)
THEN (GEN-SYM) ELSE NAME))
SPINE SP
CROSS-SECTION CS
SWEEPING-RULE SR
DISPLAY 'WIRE-FRAME))
ELSE
NIL)
) ;end-defun
;create-sub-cone[c]
;creates a new SUB-CONE for the CONE C
;if the user really wants us to.
(DEFUN CREATE-SUB-CONE (C)
(LET SC ← (CREATE-SIMPLE-CONE)
DO
(IF SC
THEN
(LET SCS ← ∂CONE:SUB-CONES[C]
SUB ← (CREATE SUB-CONE
CONE C
SUB SC)
DO
∂CONE:SUB-CONES[C] ← (ADD-AT-END SCS SUB)
(MARK-AND-REDRAW))))
) ;end-defun
;create-subpart[obj]
;adds a SUBPART to the OBJECT OBJ.
(DEFUN CREATE-SUBPART (OBJ)
(WRITE '|Do you really want to create a subpart for |
OBJ '| ? |)
(IF (READ-YES)
THEN
(TERPRI)
(WRITE '|What should I call this subpart? |)
(LET NAME ← (BIS-READ)
THEN
SP ← (CREATE OBJECT SELF NAME)
SPS ← ∂OBJECT:SUBPARTS[OBJ]
DO
∂OBJECT:SUBPARTS[OBJ] ← (ADD-AT-END SPS SP)
(WRITE '|To what OBJECT should |
NAME
'| be affixed?|)
(LET SUP ← (BIS-READ)
THEN
SUP ← (IF (IS? OBJECT SUP)
THEN
SUP
ELSE
(WRITELN '|Sorry, but | SUP
'| is not an OBJECT.|)
(WRITELN '|We are affixing | NAME
'| to | OBJ '| by default.|)
OBJ)
THEN
AF ← (CREATE AFFIXMENT SUP SUP INF NAME)
AFS ← ∂OBJECT:AFFIXMENTS[SUP]
DO
∂OBJECT:AFFIXMENTS[SUP] ← (ADD-AT-END AFS AF))))
) ;end-defun
;delete-sub-cone[c]
;allows the user to delete a SUB-CONE of the CONE C.
(DEFUN DELETE-SUB-CONE (C)
(*CATCH 'EXIT-DELETE-SUB-CONE
(WRITE '|Which one? |)
(LET I ← (READ)
SCS ← ∂CONE:SUB-CONES[C]
THEN
N ← (LENGTH SCS)
DO
(COND
((< I 1)
(WRITELN '|Sorry, but `| I '|' is not a legal answer here.|)
(*THROW 'EXIT-DELETE-SUB-CONE NIL))
((= I 1)
(LET MC ← ∂CONE:MAIN-CONE[C]
DO
(IF MC
THEN
(IF (ARE-YOU-SURE?)
THEN
∂CONE:MAIN-CONE[C] ← NIL
(DELETE-RECORD SIMPLE-CONE MC)
(MARK-AND-REDRAW)
ELSE
(WRITELN '|Aborted.|))
ELSE
(WRITELN '|There ain't no MAIN-CONE to delete.|))))
((< I (1+ (1+ N)))
(IF (ARE-YOU-SURE?)
THEN
(LET NEW-SCS ← NIL
DO
(DO ((SCS SCS (CDR SCS))
(J 2 (1+ J)))
((NULL SCS) NIL)
(LET SC ← (CAR SCS)
DO
(IF (= J I)
THEN
(DELETE-RECORD SUB-CONE SC)
ELSE
(ADD-AT-END NEW-SCS SC))))
∂CONE:SUB-CONES[C] ← NEW-SCS
(MARK-AND-REDRAW))))
(T
(WRITELN '|Sorry, but `| I '|' is not a legal command here.|)))))
) ;end-defun
;edit-affixment[af]
;allows the user to edit the AFFIXMENT AF.
(DEFUN EDIT-AFFIXMENT (AF)
(*CATCH 'EDIT-AFFIXMENT
(DO NIL (NIL NIL) ;forever
(*CATCH 'EDIT-AFFIXMENT-LOOP
(LET SUP ← ∂AFFIXMENT:SUP[AF]
INF ← ∂AFFIXMENT:INF[AF]
POS ← ∂POSITION:SYMBOLIC[∂AFFIXMENT:POSITION[AF]]
ORI ← ∂ROTATION:SYMBOLIC[∂AFFIXMENT:ORIENTATION[AF]]
DO
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- object |
SUP
'| is superior to object |
INF
'| with affixment:|)
(WRITELN '|(1) position: | POS)
(WRITELN '|(2) orientation: | ORI)
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go up to the OBJECT `| SUP '/')
(WRITELN '| 2 line-edit the POSITION of this AFFIXMENT|)
(WRITELN '| 3 line-edit the ORIENTATION of this AFFIXMENT|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-AFFIXMENT NIL))
((= 1 CMD)
∂AFFIXMENT:POSITION[AF] ← (EDIT-POSITION ∂AFFIXMENT:POSITION[AF])
(MARK-AND-REDRAW))
((= 2 CMD)
∂AFFIXMENT:ORIENTATION[AF] ← (EDIT-ORIENTATION ∂AFFIXMENT:ORIENTATION[AF])
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))))))
) ;end-defun
;edit-cone[c]
(DEFUN EDIT-CONE (C)
(*CATCH 'EDIT-CONE
(IF (NULL C)
THEN
(TERPRI)
(WRITELN '|Sorry, but there's currently no way to edit a NULL cone|)
(*THROW 'EDIT-CONE NIL))
(DO NIL (NIL NIL) ;forever
(LET MC ← ∂CONE:MAIN-CONE[C]
SCS ← NIL
DO
;Get the names of the sub-cones.
(FOR SC ε ∂CONE:SUB-CONES[C]
DO
(ADD-AT-END SCS ∂SUB-CONE:SUB[SC]))
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- cone | C '| →|)
(WRITELN '|(1 ) main-cone: | MC)
(DO ((N 2 (1+ N))
(SCS SCS (CDR SCS)))
((NULL SCS) NIL)
(WRITE LPAR
(N-CHARS N 2)
RPAR
(IF (= N 2) THEN '| sub-cones: | ELSE '| |)
(CAR SCS))
(TERPRI))
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go up to the OBJECT whence we came|)
(WRITELN '| 1 edit the MAIN-CONE|)
(WRITELN '| 2 edit the 1st SUB-CONE &c|)
(WRITELN '| 0 create a new SUB-CONE|)
(WRITELN '| DELETE delete the MAIN-CONE or a SUB-CONE|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-CONE NIL))
((EQ 'DELETE CMD)
(DELETE-SUB-CONE C))
((AND (= 1 CMD) (NULL MC))
∂CONE:MAIN-CONE[C] ← (CREATE-SIMPLE-CONE)
(MARK-AND-REDRAW))
((= 1 CMD)
(EDIT-SIMPLE-CONE MC))
((AND (FIXNUMP CMD)
(> CMD 1)
(< CMD (1+ (1+ (LENGTH SCS)))))
(EDIT-SUB-CONE (NTH (1- (1- CMD)) ∂CONE:SUB-CONES[C])))
((FIXNUMP CMD)
(CREATE-SUB-CONE C))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|)))))))
) ;end-defun
;edit-cross-section[cs]
(DEFUN EDIT-CROSS-SECTION (CS)
(*CATCH 'EDIT-CROSS-SECTION
(IF (NULL CS)
THEN
(WRITELN '|Sorry, but there's currently no way to edit a NULL cross-section.|)
(*THROW 'EDIT-CROSS-SECTION NIL))
(DO NIL (NIL NIL) ;forever
;Tell the luser what we got.
(TERPRI)
(LET TYPE ← ∂CROSS-SECTION:TYPE[CS]
DO
(CASEQ TYPE
(CIRCLE (EDIT-CROSS-SECTION-CIRCLE CS))
(RECTANGLE (EDIT-CROSS-SECTION-RECTANGLE CS))
(REGULAR-POLYGON (EDIT-CROSS-SECTION-REGULAR-POLYGON CS))
(SQUARE (EDIT-CROSS-SECTION-SQUARE CS))
(T
(WRITELN '|Sorry, but this cross-section has unknown type `| TYPE '|'|)
(*THROW 'EDIT-CROSS-SECTION NIL))))))
) ;end-defun
;edit-cross-section-circle[cs]
(DEFUN EDIT-CROSS-SECTION-CIRCLE (CS)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- cross-section | CS '| →|)
(WRITELN '|(1) type: | ∂CROSS-SECTION:TYPE[CS])
(WRITELN '|(2) radius: | ∂CROSS-SECTION:RADIUS[CS])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this CROSS-SECTION|)
(WRITELN '| 2 line-edit the value of RADIUS|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-CROSS-SECTION-TYPE CS))
((= 2 CMD)
(LET OLD ← ∂CROSS-SECTION:RADIUS[CS]
DO
(WRITE '|Change RADIUS from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂CROSS-SECTION:RADIUS[CS] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-cross-section-rectangle[cs]
(DEFUN EDIT-CROSS-SECTION-RECTANGLE (CS)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- cross-section | CS '| →|)
(WRITELN '|(1) type: | ∂CROSS-SECTION:TYPE[CS])
(WRITELN '|(2) width: | ∂CROSS-SECTION:WIDTH[CS])
(WRITELN '|(3) height: | ∂CROSS-SECTION:HEIGHT[CS])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this CROSS-SECTION|)
(WRITELN '| 2 line-edit the value of WIDTH|)
(WRITELN '| 3 line-edit the value of HEIGHT|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-CROSS-SECTION-TYPE CS))
((= 2 CMD)
(LET OLD ← ∂CROSS-SECTION:WIDTH[CS]
DO
(WRITE '|Change WIDTH from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂CROSS-SECTION:WIDTH[CS] ← NEW))
(MARK-AND-REDRAW))
((= 3 CMD)
(LET OLD ← ∂CROSS-SECTION:HEIGHT[CS]
DO
(WRITE '|Change HEIGHT from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂CROSS-SECTION:HEIGHT[CS] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-cross-section-regular-polygon[cs]
(DEFUN EDIT-CROSS-SECTION-REGULAR-POLYGON (CS)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- cross-section | CS '| →|)
(WRITELN '|(1) type: | ∂CROSS-SECTION:TYPE[CS])
(WRITELN '|(2) radius: | ∂CROSS-SECTION:RADIUS[CS])
(WRITELN '|(3) sides: | ∂CROSS-SECTION:SIDES[CS])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this CROSS-SECTION|)
(WRITELN '| 2 line-edit the value of RADIUS|)
(WRITELN '| 3 line-edit the value of SIDES|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-CROSS-SECTION-TYPE CS))
((= 2 CMD)
(LET OLD ← ∂CROSS-SECTION:RADIUS[CS]
DO
(WRITE '|Change RADIUS from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂CROSS-SECTION:RADIUS[CS] ← NEW))
(MARK-AND-REDRAW))
((= 3 CMD)
(LET OLD ← ∂CROSS-SECTION:SIDES[CS]
DO
(WRITE '|Change SIDES from | OLD '| to |)
(LET NEW ← (EDIT-FIXNUM OLD)
DO
∂CROSS-SECTION:SIDES[CS] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-cross-section-square[cs]
(DEFUN EDIT-CROSS-SECTION-SQUARE (CS)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- cross-section | CS '| →|)
(WRITELN '|(1) type: | ∂CROSS-SECTION:TYPE[CS])
(WRITELN '|(2) size: | ∂CROSS-SECTION:SIZE[CS])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this CROSS-SECTION|)
(WRITELN '| 2 line-edit the value of SIZE|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-CROSS-SECTION-TYPE CS))
((= 2 CMD)
(LET OLD ← ∂CROSS-SECTION:SIZE[CS]
DO
(WRITE '|Change SIZE from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂CROSS-SECTION:SIZE[CS] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-cross-section-type[cs]
(DEFUN EDIT-CROSS-SECTION-TYPE (CS)
(WRITELN)
(WRITELN '|Options are: CIRCLE RECTANGLE SQUARE REGULAR-POLYGON|)
(WRITE '|You want |)
(LET OLD ← ∂CROSS-SECTION:TYPE[CS]
THEN
NEW ← (BIS-WRITEREAD OLD)
DO
(IF (NOT (EQ NEW OLD))
THEN
(CASEQ NEW
(CIRCLE
∂CROSS-SECTION:TYPE[CS] ← 'CIRCLE
∂CROSS-SECTION:RADIUS[CS] ← $DEFAULT-CIRCLE-RADIUS
(MARK-AND-REDRAW))
(RECTANGLE
∂CROSS-SECTION:TYPE[CS] ← 'RECTANGLE
∂CROSS-SECTION:WIDTH[CS] ← $DEFAULT-RECTANGLE-WIDTH
∂CROSS-SECTION:HEIGHT[CS] ← $DEFAULT-RECTANGLE-HEIGHT
(MARK-AND-REDRAW))
(REGULAR-POLYGON
∂CROSS-SECTION:TYPE[CS] ← 'REGULAR-POLYGON
∂CROSS-SECTION:RADIUS[CS] ← $DEFAULT-REGULAR-POLYGON-RADIUS
∂CROSS-SECTION:SIDES[CS] ← $DEFAULT-REGULAR-POLYGON-SIDES
(MARK-AND-REDRAW))
(SQUARE
∂CROSS-SECTION:TYPE[CS] ← 'SQUARE
∂CROSS-SECTION:SIZE[CS] ← $DEFAULT-SQUARE-SIZE
(MARK-AND-REDRAW))
(T
(WRITELN '|Sorry, but `| NEW '|' is not one of the choices.|)))))
) ;end-defun
;edit-display[sc]
;enables line-editing of the DISPLAY property of SIMPLE-CONEs.
(DEFUN EDIT-DISPLAY (SC)
(WRITELN)
(WRITELN '|Options are: NIL SPINES WIRE-FRAME BACK-SURFACE HIDDEN-SURFACE INVISIBLE|)
(WRITE '|Change DISPLAY from | ∂SIMPLE-CONE:DISPLAY[SC] '| to |)
(LET OLD ← ∂SIMPLE-CONE:DISPLAY[SC]
THEN
NEW ← (BIS-WRITEREAD OLD)
DO
(IF (MEMQ NEW '(NIL SPINES WIRE-FRAME BACK-SURFACE HIDDEN-SURFACE INVISIBLE))
THEN
∂SIMPLE-CONE:DISPLAY[SC] ← NEW
(MARK-AND-REDRAW)
ELSE
(WRITELN '|Sorry, but `| NEW '|' is not one of the choices.|)))
) ;end-defun
;edit-fixnum[n]
;permits line-editing of a fixnum.
(DEFUN EDIT-FIXNUM (N)
(LET NEW ← (BIS-WRITEREAD N)
DO
(COND
((FIXNUMP NEW) NEW)
(T
(WRITELN '|Sorry, but `| NEW '|' is not a FIXNUM; retaining | N)
N)))
) ;end-defun
;edit-flonum[x]
;permits line-editing of a FLONUM.
(DEFUN EDIT-FLONUM (X)
(LET NEW ← (BIS-WRITEREAD X)
DO
(COND
((FIXNUMP NEW) (FLOAT NEW))
((FLONUMP NEW) NEW)
(T
(WRITELN '|Sorry, but `| NEW '|' is not a FLONUM; retaining | X)
X)))
) ;end-defun
;edit-object[obj]
(DEFUN EDIT-OBJECT (OBJ)
(*CATCH 'EDIT-OBJECT
(DO NIL (NIL NIL) ;forever
(*CATCH 'EDIT-OBJECT-LOOP
(LET SUP-TO ← NIL
INF-TO ← NIL
DO
;Compute things to which OBJ is SUP.
(FOR AF ε ∂OBJECT:AFFIXMENTS[OBJ]
DO
(ADD-AT-END SUP-TO ∂AFFIXMENT:INF[AF]))
;Compute things to which OBJ is INF.
(FOR AF ε (FIND-ALL AFFIXMENT INF OBJ)
DO
(ADD-AT-END INF-TO ∂AFFIXMENT:SUP[AF]))
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- object | OBJ '| →|)
(WRITELN '|(1) subparts: | ∂OBJECT:SUBPARTS[OBJ])
(WRITELN '|(2) cone-descriptor: | ∂OBJECT:CONE-DESCRIPTOR[OBJ])
(WRITELN '|(3) sup-to: | SUP-TO)
(WRITELN '|(4) inf-to: | INF-TO)
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back whence we came|)
(WRITELN '| 1 edit the SUBPARTs|)
(WRITELN '| 2 edit (create) the CONE-DESCRIPTOR|)
(WRITELN '| 3 edit AFFIXMENTs for which this OBJECT is SUP|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-OBJECT NIL))
((= 1 CMD)
(EDIT-SUBPARTS OBJ))
;Watch for a null CONE-DESCRIPTOR.
((AND (= 2 CMD)
(NULL ∂OBJECT:CONE-DESCRIPTOR[OBJ]))
(CREATE-CONE-DESCRIPTOR OBJ))
((= 2 CMD)
(EDIT-CONE ∂OBJECT:CONE-DESCRIPTOR[OBJ]))
((= 3 CMD)
(EDIT-SUP-TO OBJ))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))))))
) ;end-defun
;edit-orientation[ori-instance]
;edits a ROTATION record which may need to be created.
;The old orientation is displayed,
;and the user can change it with the line editor.
;If the new orientation is valid,
;the symbolic field is filled,
;and a demon is called to fill the other fields.
(defun edit-orientation (ori-instance)
(let instance ← (if (null ori-instance)
then (create rotation)
else ori-instance)
THEN
OLD ← ∂ROTATION:SYMBOLIC[INSTANCE]
do
(writeln)
(WRITE '|change ORIENTATION from | OLD '| to |)
(let ori ← (BIS-writeread OLD)
do
(TERPRI)
(if (not (rot-validp ori))
then
(WRITELN '|Sorry, but `| ORI '|' is not a valid ORIENTATION.|)
else
∂rotation:symbolic[instance] ← ori
(rot-create-demon instance)))
instance)
) ;end-defun
;edit-position[pos-instance]
;edits a position record which may need to be created.
;The old position is displayed,
;and the user can change it with the line editor.
;If the new position is valid,
;the symbolic field is filled,
;and a demon is called to fill the other fields.
(defun edit-position (pos-instance)
(let instance ← (if (null pos-instance)
then (create position symbolic nil)
else pos-instance)
THEN
OLD ← ∂POSITION:SYMBOLIC[INSTANCE]
do
(writeln)
(WRITE '|change POSITION from | OLD '| to |)
(let pos ← (BIS-writeread OLD)
do
(TERPRI)
(if (not (pos-validp pos))
then
(WRITELN '|Sorry, but `| POS '|' is not a valid POSITION.|)
else
∂position:symbolic[instance] ← pos
(pos-create-demon instance)))
instance)
) ;end-defun
;edit-scene[sc]
(DEFUN EDIT-SCENE (SC)
(*CATCH 'EDIT-SCENE
(DO NIL (NIL NIL) ;forever
(CATCHALL '(LAMBDA (TAG VAL)
(COND
((EQ TAG 'EDIT-SCENE) (*THROW 'EDIT-SCENE VAL))
((EQ TAG 'MODITOR) (*THROW 'MODITOR VAL))
((EQ TAG 'EDIT-SCENE-LOOP))
(T (WRITELN '|Unwinding stopped at the SCENE level.|))))
;Tell the luser what we got.
(TERPRI)
(WRITE '|--- scene | SC '| → |)
(LET NAMES ← NIL
DO
(FOR SO ε ∂SCENE:SCENE-LIST[SC]
DO
(ADD-AT-END NAMES ∂SCENE-OBJ:OBJECT[SO]))
(WRITE NAMES))
(TERPRI)
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ quit|)
(WRITELN '| CREATE create a new SCENE-OBJ|)
(WRITELN '| 1 descend to the 1st SCENE-OBJ &c|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SCENE NIL))
((EQ 'CREATE CMD)
(LET OLD-SCENE-LIST ← ∂SCENE:SCENE-LIST[SC]
DO
∂SCENE:SCENE-LIST[SC] ←
(ADD-AT-END OLD-SCENE-LIST
(CREATE-SCENE-OBJ))))
((AND (FIXNUMP CMD)
(> CMD 0)
(< CMD (1+ (LENGTH ∂SCENE:SCENE-LIST[SC]))))
(LET SO ← (NTH (1- CMD) ∂SCENE:SCENE-LIST[SC])
DO
(EDIT-SCENE-OBJ SO)))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|)))))))
) ;end-defun
;edit-scene-obj[so]
(DEFUN EDIT-SCENE-OBJ (SO)
(*CATCH 'EDIT-SCENE-OBJ
(DO NIL (NIL NIL) ;forever
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- scene-obj ---|)
(WRITELN '|(1) object: | ∂SCENE-OBJ:OBJECT[SO])
(WRITELN '|(2) position: | ∂POSITION:SYMBOLIC[∂SCENE-OBJ:POSITION[SO]])
(WRITELN '|(3) orientation: | ∂ROTATION:SYMBOLIC[∂SCENE-OBJ:ORIENTATION[SO]])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go up to the SCENE (top)|)
(WRITELN '| 1 descend to edit the OBJECT|)
(WRITELN '| 2 line-edit the POSITION of this SCENE-OBJ|)
(WRITELN '| 3 line-edit the ORIENTATION of this SCENE-OBJ|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SCENE-OBJ NIL))
((= 1 CMD)
(EDIT-OBJECT ∂SCENE-OBJ:OBJECT[SO]))
((= 2 CMD)
∂SCENE-OBJ:POSITION[SO] ← (EDIT-POSITION ∂SCENE-OBJ:POSITION[SO])
(MODITOR-DRAW))
((= 3 CMD)
∂SCENE-OBJ:ORIENTATION[SO] ← (EDIT-ORIENTATION ∂SCENE-OBJ:ORIENTATION[SO])
(MODITOR-DRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))))
) ;end-defun
;edit-simple-cone[sc]
(DEFUN EDIT-SIMPLE-CONE (SC)
(*CATCH 'EDIT-SIMPLE-CONE
(IF (NULL SC)
THEN
(WRITELN '|Sorry, but there's currently no way to edit a NULL cone|)
(*THROW 'EDIT-SIMPLE-CONE NIL))
(DO NIL (NIL NIL) ;forever
(*CATCH 'EDIT-SIMPLE-CONE-LOOP
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- simple cone | SC '| →|)
(WRITELN '|(1) spine: | ∂SIMPLE-CONE:SPINE[SC])
(WRITELN '|(2) cross-section: | ∂SIMPLE-CONE:CROSS-SECTION[SC])
(WRITELN '|(3) sweeping-rule: | ∂SIMPLE-CONE:SWEEPING-RULE[SC])
(WRITELN '|(4) display: | ∂SIMPLE-CONE:DISPLAY[SC])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back whence we came|)
(WRITELN '| 1 edit the SPINE|)
(WRITELN '| 2 edit the CROSS-SECTION|)
(WRITELN '| 3 edit the SWEEPING-RULE|)
(WRITELN '| 4 line-edit the DISPLAY property|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE NIL))
((= 1 CMD) (EDIT-SPINE ∂SIMPLE-CONE:SPINE[SC]))
((= 2 CMD) (EDIT-CROSS-SECTION ∂SIMPLE-CONE:CROSS-SECTION[SC]))
((= 3 CMD) (EDIT-SWEEPING-RULE ∂SIMPLE-CONE:SWEEPING-RULE[SC]))
((= 4 CMD) (EDIT-DISPLAY SC))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|)))))))
) ;end-defun
;edit-spine[sp]
(DEFUN EDIT-SPINE (SP)
(*CATCH 'EDIT-SPINE
(IF (NULL SP)
THEN
(WRITELN '|Sorry, but there's currently no way to edit a NULL SPINE.|)
(*THROW 'EDIT-SPINE NIL))
(DO NIL (NIL NIL) ;forever
;Tell the luser what we got.
(TERPRI)
(LET TYPE ← ∂SPINE:TYPE[SP]
DO
(CASEQ TYPE
(STRAIGHT (EDIT-SPINE-STRAIGHT SP))
(CIRCULAR-SEGMENT (EDIT-SPINE-CIRCULAR-SEGMENT SP))
(NON-PERP (EDIT-SPINE-NON-PERP SP))
(T
(WRITELN '|Sorry, but this SPINE has unknown type `| TYPE '|'|)
(*THROW 'EDIT-SPINE NIL))))))
) ;end-defun
;edit-spine-circular-segment[sp]
(DEFUN EDIT-SPINE-CIRCULAR-SEGMENT (SP)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- spine | SP '| →|)
(WRITELN '|(1) type: | ∂SPINE:TYPE[SP])
(WRITELN '|(2) radius: | ∂SPINE:RADIUS[SP])
(WRITELN '|(3) segment: | ∂SPINE:SEGMENT[SP])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this SPINE|)
(WRITELN '| 2 line-edit the value of RADIUS|)
(WRITELN '| 3 line-edit the value of SEGMENT|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-SPINE-TYPE SP))
((= 2 CMD)
(LET OLD ← ∂SPINE:RADIUS[SP]
DO
(WRITE '|Change RADIUS from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SPINE:RADIUS[SP] ← NEW))
(MARK-AND-REDRAW))
((= 3 CMD)
(LET OLD ← ∂SPINE:SEGMENT[SP]
DO
(WRITE '|Change SEGMENT from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SPINE:SEGMENT[SP] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-spine-non-perp[sp]
(DEFUN EDIT-SPINE-NON-PERP (SP)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- spine | SP '| →|)
(WRITELN '|(1) type: | ∂SPINE:TYPE[SP])
(WRITELN '|(2) length: | ∂SPINE:LENGTH[SP])
(WRITELN '|(3) y-disp: | ∂SPINE:Y-DISP[SP])
(WRITELN '|(4) z-disp: | ∂SPINE:Z-DISP[SP])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this SPINE|)
(WRITELN '| 2 line-edit the value of LENGTH|)
(WRITELN '| 3 line-edit the value of Y-DISP|)
(WRITELN '| 4 line-edit the value of Z-DISP|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-SPINE-TYPE SP))
((= 2 CMD)
(LET OLD ← ∂SPINE:LENGTH[SP]
DO
(WRITE '|Change LENGTH from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SPINE:LENGTH[SP] ← NEW))
(MARK-AND-REDRAW))
((= 3 CMD)
(LET OLD ← ∂SPINE:Y-DISP[SP]
DO
(WRITE '|Change Y-DISP from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SPINE:Y-DISP[SP] ← NEW))
(MARK-AND-REDRAW))
((= 4 CMD)
(LET OLD ← ∂SPINE:Z-DISP[SP]
DO
(WRITE '|Change Z-DISP from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SPINE:Z-DISP[SP] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-spine-straight[sp]
(DEFUN EDIT-SPINE-STRAIGHT (SP)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- spine | SP '| →|)
(WRITELN '|(1) type: | ∂SPINE:TYPE[SP])
(WRITELN '|(2) length: | ∂SPINE:LENGTH[SP])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this SPINE|)
(WRITELN '| 2 line-edit the value of LENGTH|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-SPINE-TYPE SP))
((= 2 CMD)
(LET OLD ← ∂SPINE:LENGTH[SP]
DO
(WRITE '|Change LENGTH from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SPINE:LENGTH[SP] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-spine-type[sp]
(DEFUN EDIT-SPINE-TYPE (SP)
(WRITELN)
(WRITELN '|Options are: STRAIGHT CIRCULAR-SEGMENT NON-PERP|)
(WRITE '|You want |)
(LET OLD ← ∂SPINE:TYPE[SP]
THEN
NEW ← (BIS-WRITEREAD OLD)
DO
(IF (NOT (EQ NEW OLD))
THEN
(CASEQ NEW
(STRAIGHT
∂SPINE:TYPE[SP] ← 'STRAIGHT
∂SPINE:LENGTH[SP] ← $DEFAULT-STRAIGHT-LENGTH
(MARK-AND-REDRAW))
(CIRCULAR-SEGMENT
∂SPINE:TYPE[SP] ← 'CIRCULAR-SEGMENT
∂SPINE:RADIUS[SP] ← $DEFAULT-CIRCULAR-SEGMENT-RADIUS
∂SPINE:SEGMENT[SP] ← $DEFAULT-CIRCULAR-SEGMENT-SEGMENT
(MARK-AND-REDRAW))
(NON-PERP
∂SPINE:TYPE[SP] ← 'NON-PERP
∂SPINE:LENGTH[SP] ← $DEFAULT-NON-PERP-LENGTH
∂SPINE:Y-DISP[SP] ← $DEFAULT-NON-PERP-Y-DISP
∂SPINE:Z-DISP[SP] ← $DEFAULT-NON-PERP-Z-DISP
(MARK-AND-REDRAW))
(T
(WRITELN '|Sorry, but `| NEW '|' is not one of the choices.|)))))
) ;end-defun
;edit-sub-cone[sbc]
(DEFUN EDIT-SUB-CONE (SBC)
(*CATCH 'EDIT-SUB-CONE
(DO NIL (NIL NIL) ;forever
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- sub-cone of |
∂SUB-CONE:CONE[SBC]
'| with|)
(WRITELN '|(1) simple-cone: | ∂SUB-CONE:SUB[SBC])
(WRITELN '|(2) position: | ∂POSITION:SYMBOLIC[∂SUB-CONE:POSITION[SBC]])
(WRITELN '|(3) orientation: | ∂ROTATION:SYMBOLIC[∂SUB-CONE:ORIENTATION[SBC]])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go up to the CONE-DESCRIPTOR whence we came|)
(WRITELN '| 1 edit the SIMPLE-CONE|)
(WRITELN '| 2 line-edit the POSITION of this SIMPLE-CONE|)
(WRITELN '| 3 line-edit the ORIENTATION of this SIMPLE-CONE|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SUB-CONE NIL))
((= 1 CMD)
(EDIT-SIMPLE-CONE ∂SUB-CONE:SUB[SBC]))
((= 2 CMD)
∂SUB-CONE:POSITION[SBC] ← (EDIT-POSITION ∂SUB-CONE:POSITION[SBC])
(MODITOR-DRAW))
((= 3 CMD)
∂SUB-CONE:ORIENTATION[SBC] ← (EDIT-ORIENTATION ∂SUB-CONE:ORIENTATION[SBC])
(MODITOR-DRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))))
) ;end-defun
;edit-sup-to[obj]
;allows the user to edit AFFIXMENTs which have OBJ as SUP.
(DEFUN EDIT-SUP-TO (OBJ)
(*CATCH 'EDIT-SUP-TO
(DO NIL (NIL NIL) ;forever
(*CATCH 'EDIT-SUP-TO-LOOP
(LET AFS ← ∂OBJECT:AFFIXMENTS[OBJ]
DO
;Check for no AFFIXMENTs.
(IF (NULL AFS)
THEN
(WRITELN '|Sorry, but there's no way to edit a null SUP relation.|)
(*THROW 'EDIT-SUP-TO NIL))
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- object | OBJ '| is SUPerior to: |)
(LET N ← 1
DO
(FOR AF ε AFS
DO
(WRITE LPAR)
(WRITE N)
(WRITE RPAR)
(SPACES 1)
(WRITE ∂AFFIXMENT:INF[AF])
(TERPRI)
(SETQ N (1+ N))))
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the OBJECT whence we came|)
(WRITELN '| 1 edit the 1st AFFIXMENT &c|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SUP-TO NIL))
((AND (FIXNUMP CMD)
(> CMD 0)
(< CMD (1+ (LENGTH AFS))))
(EDIT-AFFIXMENT (NTH (1- CMD) AFS)))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))))))
) ;end-defun
;edit-subparts[obj]
(DEFUN EDIT-SUBPARTS (OBJ)
(*CATCH 'EDIT-SUBPARTS
(DO NIL (NIL NIL) ;forever
(LET SPS ← ∂OBJECT:SUBPARTS[OBJ]
DO
;Tell the luser what we got.
(TERPRI)
(WRITE '|--- object | OBJ '| has subparts: |)
(IF (NULL SPS)
THEN
(WRITELN NIL)
ELSE
(TERPRI))
(DO ((N 1 (1+ N))
(SPS SPS (CDR SPS)))
((NULL SPS))
(WRITE LPAR)
(WRITE-2-DIGIT N)
(WRITE RPAR)
(SPACES 2)
(WRITE (CAR SPS))
(TERPRI))
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go upwards to the OBJECT from whence we came|)
(WRITELN '| 1 descend to the 1st SUBPART &c|)
(WRITELN '| 0 create a new SUBPART|)
(WRITELN '| ?? list universal commands|))
((AND (FIXNUMP CMD)
(> CMD 0)
(< CMD (1+ (LENGTH SPS))))
(EDIT-OBJECT (NTH (1- CMD) SPS)))
((FIXNUMP CMD)
(CREATE-SUBPART OBJ))
((EQ '↑ CMD) (*THROW 'EDIT-SUBPARTS NIL))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|)))))))
) ;end-defun
;edit-sweeping-rule[sr]
(DEFUN EDIT-SWEEPING-RULE (SR)
(*CATCH 'EDIT-SWEEPING-RULE
(IF (NULL SR)
THEN
(WRITELN '|Sorry, but there's currently no way to edit a NULL sweeping-rule.|)
(*THROW 'EDIT-SWEEPING-RULE NIL))
(DO NIL (NIL NIL) ;forever
;Tell the luser what we got.
(TERPRI)
(LET TYPE ← ∂SWEEPING-RULE:TYPE[SR]
DO
(CASEQ TYPE
(CONSTANT (EDIT-SWEEPING-RULE-CONSTANT SR))
(LINEAR (EDIT-SWEEPING-RULE-LINEAR SR))
(BILINEAR (EDIT-SWEEPING-RULE-BILINEAR SR))
(T
(WRITELN '|Sorry, but this SWEEPING-RULE has unknown type `| TYPE '|'|)
(*THROW 'EDIT-SWEEPING-RULE NIL))))))
) ;end-defun
;edit-sweeping-rule-bilinear[sr]
(DEFUN EDIT-SWEEPING-RULE-BILINEAR (SR)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- SWEEPING-RULE | SR '| →|)
(WRITELN '|(1) type: | ∂SWEEPING-RULE:TYPE[SR])
(WRITELN '|(2) yscale: | ∂SWEEPING-RULE:YSCALE[SR])
(WRITELN '|(3) zscale: | ∂SWEEPING-RULE:ZSCALE[SR])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this SWEEPING-RULE|)
(WRITELN '| 2 line-edit the value of YSCALE|)
(WRITELN '| 3 line-edit the value of ZSCALE|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-SWEEPING-RULE-TYPE SR))
((= 2 CMD)
(LET OLD ← ∂SWEEPING-RULE:YSCALE[SR]
DO
(WRITE '|Change YSCALE from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SWEEPING-RULE:YSCALE[SR] ← NEW))
(MARK-AND-REDRAW))
((= 3 CMD)
(LET OLD ← ∂SWEEPING-RULE:ZSCALE[SR]
DO
(WRITE '|Change ZSCALE from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SWEEPING-RULE:ZSCALE[SR] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-sweeping-rule-constant[sr]
(DEFUN EDIT-SWEEPING-RULE-CONSTANT (SR)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- SWEEPING-RULE | SR '| →|)
(WRITELN '|(1) type: | ∂SWEEPING-RULE:TYPE[SR])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this SWEEPING-RULE|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-SWEEPING-RULE-TYPE SR))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-sweeping-rule-linear[sr]
(DEFUN EDIT-SWEEPING-RULE-LINEAR (SR)
;Tell the luser what we got.
(TERPRI)
(WRITELN '|--- SWEEPING-RULE | SR '| →|)
(WRITELN '|(1) type: | ∂SWEEPING-RULE:TYPE[SR])
(WRITELN '|(2) ratio: | ∂SWEEPING-RULE:RATIO[SR])
;What's he wanna do?
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(LET CMD ← (BIS-READ)
DO
(COND
((UNIVERSAL-CMD CMD))
((MEMQ CMD '(? HELP))
(TERPRI)
(WRITELN '| ↑ go back to the SIMPLE-CONE whence we came|)
(WRITELN '| 1 line-edit the TYPE of this SWEEPING-RULE|)
(WRITELN '| 2 line-edit the value of RATIO|)
(WRITELN '| ?? list universal commands|))
((EQ '↑ CMD) (*THROW 'EDIT-SIMPLE-CONE-LOOP NIL))
((= 1 CMD) (EDIT-SWEEPING-RULE-TYPE SR))
((= 2 CMD)
(LET OLD ← ∂SWEEPING-RULE:RATIO[SR]
DO
(WRITE '|Change RATIO from | OLD '| to |)
(LET NEW ← (EDIT-FLONUM OLD)
DO
∂SWEEPING-RULE:RATIO[SR] ← NEW))
(MARK-AND-REDRAW))
(T (WRITELN '|Sorry, but `| CMD '|' is not a valid command here.|))))
) ;end-defun
;edit-sweeping-rule-type[sr]
(DEFUN EDIT-SWEEPING-RULE-TYPE (SR)
(WRITELN)
(WRITELN '|Options are: CONSTANT LINEAR BILINEAR|)
(WRITE '|You want |)
(LET OLD ← ∂SWEEPING-RULE:TYPE[SR]
THEN
NEW ← (BIS-WRITEREAD OLD)
DO
(IF (NOT (EQ NEW OLD))
THEN
(CASEQ NEW
(LINEAR
∂SWEEPING-RULE:TYPE[SR] ← 'LINEAR
∂SWEEPING-RULE:RATIO[SR] ← $DEFAULT-LINEAR-RATIO
(MARK-AND-REDRAW))
(BILINEAR
∂SWEEPING-RULE:TYPE[SR] ← 'BILINEAR
∂SWEEPING-RULE:YSCALE[SR] ← 0.1
∂SWEEPING-RULE:ZSCALE[SR] ← 0.5
(MARK-AND-REDRAW))
(CONSTANT
∂SWEEPING-RULE:TYPE[SR] ← 'CONSTANT
(MARK-AND-REDRAW))
(T
(WRITELN '|Sorry, but `| NEW '|' is not one of the choices.|)))))
) ;end-defun
;mark-written[name]
;remembers that the thing with user-name NAME has been written out.
(DEFUN MARK-WRITTEN (NAME)
(DECLARE (SPECIAL MODITOR-WRITTEN-LIST))
(SETQ MODITOR-WRITTEN-LIST
(CONS NAME MODITOR-WRITTEN-LIST))
) ;end-defun
;marked-written[name]
;returns T if and only if the thing with user-name NAME has been written out.
(DEFUN MARKED-WRITTEN (NAME)
(DECLARE (SPECIAL MODITOR-WRITTEN-LIST))
(MEMQ NAME MODITOR-WRITTEN-LIST)
) ;end-defun
;moditor[]
(DEFUN MODITOR ()
(AUTOLD-BIS-CAMERA)
(AUTOLD-BIS-COLLID)
(AUTOLD-BIS-SIMULA)
(AUTOLD-BIS-BARM)
(AUTOLD-BIS-VAL)
(IF (NOT $SIMULATOR-CAMERA-SET)
THEN
(SIMULATOR-DEFAULT-CAMERA)
(SETQ $SIMULATOR-CAMERA-SET T))
(*CATCH 'MODITOR
(INITIALISE-SIMULATOR)
(IF (EQ 'DD (TERMINAL-ID)) THEN (GET-DD-CHAN))
(SET-MODITOR-SCREEN)
(MODITOR-DRAW)
(EDIT-SCENE $CURRENT-SCENE))
(WRITELN '|... Good-by from MODITOR ...|)
'*
) ;end-defun
;moditor-cmd-exe[]
;adds another file to the stack of EXE files.
(DEFUN MODITOR-CMD-EXE ()
(WRITE '|Command file? |)
(LET FILE ← (BIS-READ-FILE-NAME 'EXE)
THEN
INFILE ← (EOPEN FILE '(IN ASCII))
DO
(WRITE '|Reading EXE file: |)
(WRITE-A-FILE-SPEC FILE)(TERPRI)
(SETQ $EXE-FILES (CONS INFILE $EXE-FILES)))
) ;end-defun
(DEFUN MODITOR-CMD-UVAR ()
(*CATCH 'MODITOR-CMD-UVAR
(WRITE '|Which UVAR would you like to edit? |)
(LET UVAR ← (BIS-READ)
MEANWHILE
(TERPRI)
(IF (NOT (MEMQ UVAR ∂DB-INDEX:UVARS[$DB-INDEX]))
THEN
(WRITELN '|Sorry, but `| UVAR '|' is not a USER-VARIABLE|)
(*THROW 'MODITOR-CMD-UVAR NIL))
THEN
OLD ← ∂UVAR:SYMBOLIC[UVAR]
MEANWHILE
(WRITE '|Change from |
∂UVAR:SYMBOLIC[UVAR]
'| to |)
THEN
NEW ← (BIS-WRITEREAD OLD)
DO
(SET UVAR NEW)
∂UVAR:SYMBOLIC[UVAR] ← NEW)
(MARK-AND-REDRAW))
) ;end-defun
;moditor-cmd-w[]
;writes out $CURRENT-SCENE in textual form suitable for PARSE.
(DEFUN MODITOR-CMD-W ()
(DECLARE (SPECIAL FILE $OK))
(WRITE '|MOD file? |)
(LET FILE ← (BIS-READ-FILE-NAME 'MOD)
$OK ← T
DO
(WRITE '|Writing MOD file: |)
(WRITE-A-FILE-SPEC FILE)(TERPRI)
(WRITE-A-FILE (CAR FILE) (CADR FILE) (CDDR FILE)
(WRITELN '|;;; ACRONYM model file|)
(WRITE '|;;; system created|)
(WRITE-WHEN $CREATION)
(WRITE '| by |)
(WRITELN $CREATOR)
(WRITE '|;;; model written|)
(WRITE-WHEN (DUMP-DATE-TIME))
(WRITE '| by |)
(WRITELN $UNAME)
(WRITE-SCENE $CURRENT-SCENE))
(IF (NOT $OK)
THEN
(WRITELN '|Wuh-oh ... something went wrong ... check output for `UNKNOWN'|)))
) ;end-defun
;moditor-draw[]
;redraws the screen for MODITOR.
(DEFUN MODITOR-DRAW ()
(IF (EQ 'DD (TERMINAL-ID))
THEN
(EVAL $DOSTUFF))
) ;end-defun
;set-moditor-screen[]
;sets the piece of paper appropriately for moditor:
(DEFUN SET-MODITOR-SCREEN ()
(DECLARE (SPECIAL $PP1))
(IF (EQ 'DD (TERMINAL-ID))
THEN
(SETQ $PP1 1)
(SELPP $PP1)
(PPPOS 0.0 0.325)
(PPDISP (LIST $PP1)))
) ;end-defun
;universal-cmd[cmd]
;executes CMD if it's a universal command, returning T,
;and otherwise returns NIL.
(DEFUN UNIVERSAL-CMD (CMD)
(COND
((EQ CMD '??)
(TERPRI)
(WRITELN '|Universal commands are:|)
(WRITELN '| Q exit MODITOR|)
(WRITELN '| EXE take commands from a disk file|)
(WRITELN '| V enable keystroke changes to the View|)
(WRITELN '| SLEEP go to sleep for N minutes|)
(WRITELN '| UVAR change the value of a USER-VARIABLE|)
(WRITELN '| W write a model file of the current scene|)
(WRITELN '| ↑OBJECT go up from here to an OBJECT|)
(WRITELN '| ↑SCENE go up from here to the SCENE (top)|))
((MEMQ CMD '(Q EXIT HALT QUIT STOP)) (*THROW 'MODITOR T))
((EQ CMD 'V) ;change camera parameters
(SUPER)
(SET-MODITOR-SCREEN)
T)
((EQ CMD 'EXE) (MODITOR-CMD-EXE) T)
((EQ CMD 'SLEEP) (CMD-SLEEP) T)
((EQ CMD 'UVAR) (MODITOR-CMD-UVAR) T)
((EQ CMD 'W) (MODITOR-CMD-W) T)
((EQ CMD '↑OBJECT) (*THROW 'EDIT-OBJECT-LOOP T))
((EQ CMD '↑SCENE) (*THROW 'EDIT-SCENE-LOOP T))
(T NIL))
) ;end-defun
;write-affixment[af]
;writes the AFFIXMENT AF in PARSE form.
(DEFUN WRITE-AFFIXMENT (AF)
(WRITE LPAR '|affix | ∂AFFIXMENT:INF[AF] '| to | ∂AFFIXMENT:SUP[AF])
(LET POS ← ∂AFFIXMENT:POSITION[AF]
ORI ← ∂AFFIXMENT:ORIENTATION[AF]
THEN
POS-SYM ← ∂POSITION:SYMBOLIC[POS]
ORI-SYM ← ∂ROTATION:SYMBOLIC[ORI]
DO
(IF (OR POS-SYM ORI-SYM)
THEN
(WRITE '| with|)
(IF POS-SYM THEN
(WRITE '| pos|)
(FOR IPOS ε POS-SYM DO (WRITE '| |) (PRIN1 IPOS)))
(IF ORI-SYM THEN
(WRITE '| ori|)
(FOR IORI ε ORI-SYM DO (WRITE '| |) (PRIN1 IORI)))))
(WRITE RPAR)
(TERPRI)
) ;end-defun
;write-affixments[obj]
;writes out the AFFIXMENTs of OBJECT OBJ,
;then examines the AFFIXMENTs of OBJECTs below it.
;We thus traverse the AFFIXMENT tree in pre-order.
(DEFUN WRITE-AFFIXMENTS (OBJ)
(FOR AF ε ∂OBJECT:AFFIXMENTS[OBJ] DO
(WRITE-AFFIXMENT AF)
(WRITE-AFFIXMENTS ∂AFFIXMENT:INF[AF]))
) ;end-defun
;write-cone[cd,n]
;writes out the CONE CD in PARSE form.
;N is the number of spaces to indent.
(DEFUN WRITE-CONE (CD N)
(INDENT N)
(WRITE LPAR)
(WRITE '|define cone |)
(IF (USER-NAME CD)
THEN (WRITE CD) (WRITE'| |))
(WRITE '|having|)
(TERPRI)
(LET MC ← ∂CONE:MAIN-CONE[CD]
DO
(IF MC
THEN
(INDENT (+ 2 N))
(WRITE '|main-cone|)
(COND
((SYSTEM-NAME MC) (TERPRI) (WRITE-SC MC (+ 4 N)))
((MARKED-WRITTEN MC) (WRITE MC))
(T (TERPRI) (WRITE-SC MC (+ 4 N)) (MARK-WRITTEN MC)))))
(WRITE RPAR)
) ;end-defun
;write-cs[cs,n]
;writes out the CROSS-SECTION CS in PARSE format.
;N is the number of spaces to indent.
(DEFUN WRITE-CS (CS N)
(DECLARE (SPECIAL $OK))
(INDENT N)
(WRITE LPAR)
(WRITE '|define cross-section |)
(IF (USER-NAME CS)
THEN (WRITE CS) (WRITE '| |))
(WRITE '|having type |)
(LET TYPE ← ∂CROSS-SECTION:TYPE[CS]
DO
(CASEQ TYPE
(CIRCLE (WRITE '|CIRCLE radius |
∂CROSS-SECTION:RADIUS[CS]))
(SQUARE (WRITE '|SQUARE size |
∂CROSS-SECTION:SIZE[CS]))
(RECTANGLE (WRITE '|RECTANGLE width |
∂CROSS-SECTION:WIDTH[CS]
'| height |
∂CROSS-SECTION:HEIGHT[CS]))
(REGULAR-POLYGON (WRITE '|REGULAR-POLYGON|)
(WRITE '| sides |)
(WRITE ∂CROSS-SECTION:SIDES[CS])
(WRITE '| radius |)
(WRITE ∂CROSS-SECTION:RADIUS[CS]))
(T (WRITE '|UNKNOWN|)
(SETQ $OK NIL))))
(WRITE RPAR)
) ;end-defun
;write-ob[ob]
;writes out the OBJECT OB in PARSE form.
;First write the CONE-DESCRIPTOR;
;then write the SUB-CONE statements;
;then recursively call WRITE-OB for all subparts;
;affixments are currently ignored.
(DEFUN WRITE-OB (OB)
(WRITE LPAR)
(WRITE '|define object |)
(WRITE OB)
(LET CD ← ∂OBJECT:CONE-DESCRIPTOR[OB]
SPDS ← ∂OBJECT:SUBPARTS[OB]
DO
(IF (OR CD SPDS) THEN (WRITE '| having |))
(IF CD THEN
(TERPRI)
(WRITE '| cone-descriptor |)
(COND
((SYSTEM-NAME CD) (TERPRI) (WRITE-CONE CD 4))
((MARKED-WRITTEN CD) (WRITE CD))
(T (TERPRI) (WRITE-CONE CD 4) (MARK-WRITTEN CD))))
(FOR SPD ε SPDS DO
(TERPRI)
(WRITE '| subpart |)
(WRITE SPD))
(WRITE RPAR)
(TERPRI)
(LET SUB-CONES ← ∂OBJECT:CONE-DESCRIPTOR:SUB-CONES[OB]
DO
(FOR SUB-CONE ε SUB-CONES DO
(WRITE-SUB-CONE SUB-CONE))))
(FOR SPD ε ∂OBJECT:SUBPARTS[OB] DO
(WRITE-OB SPD))
) ;end-defun
;write-sc[sc,n]
;writes out the SIMPLE-CONE SC in PARSE format.
;N is the number of spaces to indent.
(DEFUN WRITE-SC (SC N)
(INDENT N)
(WRITE LPAR)
(WRITE '|define simple-cone |)
(IF (USER-NAME SC)
THEN (WRITE SC) (WRITE '| |))
(WRITE '|having|)
(TERPRI)
(LET SP ← ∂SIMPLE-CONE:SPINE[SC]
DO
(INDENT (+ 2 N)) (WRITE '|spine |)
(COND
;If a system name, then write it out.
((SYSTEM-NAME SP) (TERPRI) (WRITE-SP SP (+ 4 N)))
;If a user name and written already, then just write the name.
((MARKED-WRITTEN SP) (WRITE SP))
;If a user name but not yet written out, then write it out.
(T (TERPRI) (WRITE-SP SP (+ 4 N)) (MARK-WRITTEN SP)))
(TERPRI))
(LET CS ← ∂SIMPLE-CONE:CROSS-SECTION[SC]
DO
(INDENT (+ 2 N)) (WRITE '|cross-section |)
(COND
;If a system name, then write it out.
((SYSTEM-NAME CS) (TERPRI) (WRITE-CS CS (+ 4 N)))
;If a user name and written already, then just write the name.
((MARKED-WRITTEN CS) (WRITE CS))
;If a user name but not yet written out, then write it out.
(T (TERPRI) (WRITE-CS CS (+ 4 N)) (MARK-WRITTEN CS)))
(TERPRI))
(LET SR ← ∂SIMPLE-CONE:SWEEPING-RULE[SC]
DO
(INDENT (+ 2 N)) (WRITE '|sweeping-rule |)
(COND
;If a system name, then write it out.
((SYSTEM-NAME SR) (TERPRI) (WRITE-SR SR (+ 4 N)))
;If a user name and written already, then just write the name.
((MARKED-WRITTEN SR) (WRITE SR))
;If a user name but not yet written out, then write it out.
(T (TERPRI) (WRITE-SR SR (+ 4 N)) (MARK-WRITTEN SR))))
(LET DISPLAY ← ∂SIMPLE-CONE:DISPLAY[SC]
DO
(IF DISPLAY
THEN (TERPRI) (INDENT (+ 2 N)) (WRITE '|display | DISPLAY)))
(LET FACE0 ← ∂SIMPLE-CONE:FACE0[SC]
DO
(IF FACE0
THEN (TERPRI) (INDENT (+ 2 N)) (WRITE '|face0 | FACE0)))
(LET FACE1 ← ∂SIMPLE-CONE:FACE1[SC]
DO
(IF FACE1
THEN (TERPRI) (INDENT (+ 2 N)) (WRITE '|face1 | FACE1)))
(WRITE RPAR)
) ;end-defun
;write-scene[scene]
;writes out SCENE in PARSE form.
;First write the USER-VARIABLEs and USER-CONSTANTs;
;then write the SCENE-OBJECTs;
;then write out the AFFIXMENT tree.
(DECLARE (SPECIAL MODITOR-WRITTEN-LIST))
(DEFUN WRITE-SCENE (SCENE)
(LET MODITOR-WRITTEN-LIST ← NIL
DO
(WRITE-UVARS-UCONS)
(FOR SO ε ∂SCENE:SCENE-LIST[SCENE] DO
(WRITE-SO SO)))
(FOR SO ε ∂SCENE:SCENE-LIST[SCENE] DO
(LET OBJ ← ∂SCENE-OBJ:OBJECT[SO]
DO
(WRITE-AFFIXMENTS OBJ)))
) ;end-defun
(DECLARE (UNSPECIAL MODITOR-WRITTEN-LIST))
;write-so[so]
;writes out the SCENE-OBJ SO in PARSE form.
;First write the OBJECT part,
;then do the required PUT.
(DEFUN WRITE-SO (SO)
(LET OBJ ← ∂SCENE-OBJ:OBJECT[SO]
POS ← ∂SCENE-OBJ:POSITION[SO]
ORI ← ∂SCENE-OBJ:ORIENTATION[SO]
DO
(WRITE-OB OBJ)
(WRITE LPAR)
(WRITE '|put |)
(WRITE OBJ)
(LET POS-SYM ← ∂POSITION:SYMBOLIC[POS]
ORI-SYM ← ∂ROTATION:SYMBOLIC[ORI]
DO
(IF (OR POS-SYM ORI-SYM) THEN
(WRITE '| with|)
(IF POS-SYM THEN
(WRITE '| pos|)
(FOR P ε POS-SYM DO
(WRITE '| |) (PRIN1 P)))
(IF ORI-SYM THEN
(WRITE '| ori|)
(FOR O ε ORI-SYM DO
(WRITE '| |) (PRIN1 O))))))
(WRITE RPAR)
(TERPRI)
) ;end-defun
;write-sp[sp,n]
(DEFUN WRITE-SP (SP N)
(DECLARE (SPECIAL $OK))
(INDENT N)
(WRITE LPAR)
(WRITE '|define spine |)
(IF (USER-NAME SP)
THEN (WRITE SP) (WRITE '| |))
(WRITE '|having type |)
(LET TYPE ← ∂SPINE:TYPE[SP]
DO
(CASEQ TYPE
(CIRCULAR-SEGMENT (WRITE '|CIRCULAR-SEGMENT radius |
∂SPINE:RADIUS[SP]
'| segment |
∂SPINE:SEGMENT[SP]))
(STRAIGHT (WRITE '|STRAIGHT length |
∂SPINE:LENGTH[SP]))
(NON-PERP (WRITE '|NON-PERP|)
(WRITE '| length | ∂SPINE:LENGTH[SP])
(WRITE '| y-disp | ∂SPINE:Y-DISP[SP])
(WRITE '| z-disp | ∂SPINE:Z-DISP[SP]))
(T (WRITE '|UNKNOWN|)
(SETQ $OK NIL))))
(WRITE RPAR)
) ;end-defun
;write-sr[sr,n]
;writes out the SWEEPING-RULE SR in PARSE format.
;N is the number of spaces to indent.
(DEFUN WRITE-SR (SR N)
(DECLARE (SPECIAL $OK))
(INDENT N)
(WRITE LPAR)
(WRITE '|define sweeping-rule |)
(IF (USER-NAME SR)
THEN (WRITE SR) (WRITE '| |))
(WRITE '|having type |)
(LET TYPE ← ∂SWEEPING-RULE:TYPE[SR]
DO
(CASEQ TYPE
('CONSTANT (WRITE '|CONSTANT|))
('LINEAR (WRITE '|LINEAR ratio | ∂SWEEPING-RULE:RATIO[SR]))
('BILINEAR (WRITE '|BILINEAR yscale |
∂SWEEPING-RULE:YSCALE[SR]
'| zscale |
∂SWEEPING-RULE:ZSCALE[SR]))
(T (WRITE '|UNKNOWN|)
(SETQ $OK NIL))))
(WRITE RPAR)
) ;end-defun
;write-sub-cone[sub-cone]
;writes out a SUB-CONE statement in PARSE form.
(DEFUN WRITE-SUB-CONE (SUB-CONE)
(LET SUB ← ∂SUB-CONE:SUB[SUB-CONE]
CONE ← ∂SUB-CONE:CONE[SUB-CONE]
POS ← ∂SUB-CONE:POSITION[SUB-CONE]
ORI ← ∂SUB-CONE:ORIENTATION[SUB-CONE]
THEN
POS-SYM ← ∂POSITION:SYMBOLIC[POS]
ORI-SYM ← ∂ROTATION:SYMBOLIC[ORI]
DO
(WRITE LPAR)
(WRITE '|sub-cone|)
(COND
((SYSTEM-NAME SUB) (TERPRI) (WRITE-SC SUB 2))
((MARKED-WRITTEN SUB) (WRITE SUB))
(T (TERPRI) (WRITE-SC SUB 2) (MARK-WRITTEN SUB)))
(TERPRI)
(WRITE '| of |)
(WRITE CONE)
(IF (OR POS-SYM ORI-SYM) THEN
(WRITE '| with|)
(IF POS-SYM THEN
(WRITE '| pos|)
(FOR P ε POS-SYM DO
(WRITE '| |) (PRIN1 P)))
(IF ORI-SYM THEN
(WRITE '| ori|)
(FOR O ε ORI-SYM DO
(WRITE '| |) (PRIN1 O)))))
(WRITE RPAR)
(TERPRI)
) ;end-defun
;write-uvars-ucons[]
;writes out each user constant and user variable
;found in $db-index with its symbolic value.
(DEFUN WRITE-UVARS-UCONS ()
(FOR UCON ε ∂DB-INDEX:UCONS[$DB-INDEX] DO
(WRITE '|(USER-CONSTANT | UCON '| |)
(PRIN1 ∂UCON:SYMBOLIC[UCON])
(WRITELN '|)|))
(WRITELN)
(FOR UVAR ε ∂DB-INDEX:UVARS[$DB-INDEX] DO
(WRITE '|(USER-VARIABLE | UVAR '| |)
(PRIN1 ∂UVAR:SYMBOLIC[UVAR])
(WRITELN '|)|)))